home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / HTTP / Daemon.pm < prev    next >
Text File  |  2008-04-07  |  23KB  |  886 lines
  1. package HTTP::Daemon;
  2.  
  3. use strict;
  4. use vars qw($VERSION @ISA $PROTO $DEBUG);
  5.  
  6. $VERSION = "5.810";
  7.  
  8. use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
  9. @ISA=qw(IO::Socket::INET);
  10.  
  11. $PROTO = "HTTP/1.1";
  12.  
  13.  
  14. sub new
  15. {
  16.     my($class, %args) = @_;
  17.     $args{Listen} ||= 5;
  18.     $args{Proto}  ||= 'tcp';
  19.     return $class->SUPER::new(%args);
  20. }
  21.  
  22.  
  23. sub accept
  24. {
  25.     my $self = shift;
  26.     my $pkg = shift || "HTTP::Daemon::ClientConn";
  27.     my ($sock, $peer) = $self->SUPER::accept($pkg);
  28.     if ($sock) {
  29.         ${*$sock}{'httpd_daemon'} = $self;
  30.         return wantarray ? ($sock, $peer) : $sock;
  31.     }
  32.     else {
  33.         return;
  34.     }
  35. }
  36.  
  37.  
  38. sub url
  39. {
  40.     my $self = shift;
  41.     my $url = $self->_default_scheme . "://";
  42.     my $addr = $self->sockaddr;
  43.     if (!$addr || $addr eq INADDR_ANY) {
  44.      require Sys::Hostname;
  45.      $url .= lc Sys::Hostname::hostname();
  46.     }
  47.     else {
  48.     $url .= gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
  49.     }
  50.     my $port = $self->sockport;
  51.     $url .= ":$port" if $port != $self->_default_port;
  52.     $url .= "/";
  53.     $url;
  54. }
  55.  
  56.  
  57. sub _default_port {
  58.     80;
  59. }
  60.  
  61.  
  62. sub _default_scheme {
  63.     "http";
  64. }
  65.  
  66.  
  67. sub product_tokens
  68. {
  69.     "libwww-perl-daemon/$HTTP::Daemon::VERSION";
  70. }
  71.  
  72.  
  73.  
  74. package HTTP::Daemon::ClientConn;
  75.  
  76. use vars qw(@ISA $DEBUG);
  77. use IO::Socket ();
  78. @ISA=qw(IO::Socket::INET);
  79. *DEBUG = \$HTTP::Daemon::DEBUG;
  80.  
  81. use HTTP::Request  ();
  82. use HTTP::Response ();
  83. use HTTP::Status;
  84. use HTTP::Date qw(time2str);
  85. use LWP::MediaTypes qw(guess_media_type);
  86. use Carp ();
  87.  
  88. my $CRLF = "\015\012";   # "\r\n" is not portable
  89. my $HTTP_1_0 = _http_version("HTTP/1.0");
  90. my $HTTP_1_1 = _http_version("HTTP/1.1");
  91.  
  92.  
  93. sub get_request
  94. {
  95.     my($self, $only_headers) = @_;
  96.     if (${*$self}{'httpd_nomore'}) {
  97.         $self->reason("No more requests from this connection");
  98.     return;
  99.     }
  100.  
  101.     $self->reason("");
  102.     my $buf = ${*$self}{'httpd_rbuf'};
  103.     $buf = "" unless defined $buf;
  104.  
  105.     my $timeout = $ {*$self}{'io_socket_timeout'};
  106.     my $fdset = "";
  107.     vec($fdset, $self->fileno, 1) = 1;
  108.     local($_);
  109.  
  110.   READ_HEADER:
  111.     while (1) {
  112.     # loop until we have the whole header in $buf
  113.     $buf =~ s/^(?:\015?\012)+//;  # ignore leading blank lines
  114.     if ($buf =~ /\012/) {  # potential, has at least one line
  115.         if ($buf =~ /^\w+[^\012]+HTTP\/\d+\.\d+\015?\012/) {
  116.         if ($buf =~ /\015?\012\015?\012/) {
  117.             last READ_HEADER;  # we have it
  118.         }
  119.         elsif (length($buf) > 16*1024) {
  120.             $self->send_error(413); # REQUEST_ENTITY_TOO_LARGE
  121.             $self->reason("Very long header");
  122.             return;
  123.         }
  124.         }
  125.         else {
  126.         last READ_HEADER;  # HTTP/0.9 client
  127.         }
  128.     }
  129.     elsif (length($buf) > 16*1024) {
  130.         $self->send_error(414); # REQUEST_URI_TOO_LARGE
  131.         $self->reason("Very long first line");
  132.         return;
  133.     }
  134.     print STDERR "Need more data for complete header\n" if $DEBUG;
  135.     return unless $self->_need_more($buf, $timeout, $fdset);
  136.     }
  137.     if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) {
  138.     ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0");
  139.     $self->send_error(400);  # BAD_REQUEST
  140.     $self->reason("Bad request line: $buf");
  141.     return;
  142.     }
  143.     my $method = $1;
  144.     my $uri = $2;
  145.     my $proto = $3 || "HTTP/0.9";
  146.     $uri = "http://$uri" if $method eq "CONNECT";
  147.     $uri = $HTTP::URI_CLASS->new($uri, $self->daemon->url);
  148.     my $r = HTTP::Request->new($method, $uri);
  149.     $r->protocol($proto);
  150.     ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto);
  151.     ${*$self}{'httpd_head'} = ($method eq "HEAD");
  152.  
  153.     if ($proto >= $HTTP_1_0) {
  154.     # we expect to find some headers
  155.     my($key, $val);
  156.       HEADER:
  157.     while ($buf =~ s/^([^\012]*)\012//) {
  158.         $_ = $1;
  159.         s/\015$//;
  160.         if (/^([^:\s]+)\s*:\s*(.*)/) {
  161.         $r->push_header($key, $val) if $key;
  162.         ($key, $val) = ($1, $2);
  163.         }
  164.         elsif (/^\s+(.*)/) {
  165.         $val .= " $1";
  166.         }
  167.         else {
  168.         last HEADER;
  169.         }
  170.     }
  171.     $r->push_header($key, $val) if $key;
  172.     }
  173.  
  174.     my $conn = $r->header('Connection');
  175.     if ($proto >= $HTTP_1_1) {
  176.     ${*$self}{'httpd_nomore'}++ if $conn && lc($conn) =~ /\bclose\b/;
  177.     }
  178.     else {
  179.     ${*$self}{'httpd_nomore'}++ unless $conn &&
  180.                                            lc($conn) =~ /\bkeep-alive\b/;
  181.     }
  182.  
  183.     if ($only_headers) {
  184.     ${*$self}{'httpd_rbuf'} = $buf;
  185.         return $r;
  186.     }
  187.  
  188.     # Find out how much content to read
  189.     my $te  = $r->header('Transfer-Encoding');
  190.     my $ct  = $r->header('Content-Type');
  191.     my $len = $r->header('Content-Length');
  192.  
  193.     # Act on the Expect header, if it's there
  194.     for my $e ( $r->header('Expect') ) {
  195.         if( lc($e) eq '100-continue' ) {
  196.             $self->send_status_line(100);
  197.         }
  198.         else {
  199.             $self->send_error(417);
  200.             $self->reason("Unsupported Expect header value");
  201.             return;
  202.         }
  203.     }
  204.  
  205.     if ($te && lc($te) eq 'chunked') {
  206.     # Handle chunked transfer encoding
  207.     my $body = "";
  208.       CHUNK:
  209.     while (1) {
  210.         print STDERR "Chunked\n" if $DEBUG;
  211.         if ($buf =~ s/^([^\012]*)\012//) {
  212.         my $chunk_head = $1;
  213.         unless ($chunk_head =~ /^([0-9A-Fa-f]+)/) {
  214.             $self->send_error(400);
  215.             $self->reason("Bad chunk header $chunk_head");
  216.             return;
  217.         }
  218.         my $size = hex($1);
  219.         last CHUNK if $size == 0;
  220.  
  221.         my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end
  222.         # must read until we have a complete chunk
  223.         while ($missing > 0) {
  224.             print STDERR "Need $missing more bytes\n" if $DEBUG;
  225.             my $n = $self->_need_more($buf, $timeout, $fdset);
  226.             return unless $n;
  227.             $missing -= $n;
  228.         }
  229.         $body .= substr($buf, 0, $size);
  230.         substr($buf, 0, $size+2) = '';
  231.  
  232.         }
  233.         else {
  234.         # need more data in order to have a complete chunk header
  235.         return unless $self->_need_more($buf, $timeout, $fdset);
  236.         }
  237.     }
  238.     $r->content($body);
  239.  
  240.     # pretend it was a normal entity body
  241.     $r->remove_header('Transfer-Encoding');
  242.     $r->header('Content-Length', length($body));
  243.  
  244.     my($key, $val);
  245.       FOOTER:
  246.     while (1) {
  247.         if ($buf !~ /\012/) {
  248.         # need at least one line to look at
  249.         return unless $self->_need_more($buf, $timeout, $fdset);
  250.         }
  251.         else {
  252.         $buf =~ s/^([^\012]*)\012//;
  253.         $_ = $1;
  254.         s/\015$//;
  255.         if (/^([\w\-]+)\s*:\s*(.*)/) {
  256.             $r->push_header($key, $val) if $key;
  257.             ($key, $val) = ($1, $2);
  258.         }
  259.         elsif (/^\s+(.*)/) {
  260.             $val .= " $1";
  261.         }
  262.         elsif (!length) {
  263.             last FOOTER;
  264.         }
  265.         else {
  266.             $self->reason("Bad footer syntax");
  267.             return;
  268.         }
  269.         }
  270.     }
  271.     $r->push_header($key, $val) if $key;
  272.  
  273.     }
  274.     elsif ($te) {
  275.     $self->send_error(501);     # Unknown transfer encoding
  276.     $self->reason("Unknown transfer encoding '$te'");
  277.     return;
  278.  
  279.     }
  280.     elsif ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) {
  281.     # Handle multipart content type
  282.     my $boundary = "$CRLF--$1--$CRLF";
  283.     my $index;
  284.     while (1) {
  285.         $index = index($buf, $boundary);
  286.         last if $index >= 0;
  287.         # end marker not yet found
  288.         return unless $self->_need_more($buf, $timeout, $fdset);
  289.     }
  290.     $index += length($boundary);
  291.     $r->content(substr($buf, 0, $index));
  292.     substr($buf, 0, $index) = '';
  293.  
  294.     }
  295.     elsif ($len) {
  296.     # Plain body specified by "Content-Length"
  297.     my $missing = $len - length($buf);
  298.     while ($missing > 0) {
  299.         print "Need $missing more bytes of content\n" if $DEBUG;
  300.         my $n = $self->_need_more($buf, $timeout, $fdset);
  301.         return unless $n;
  302.         $missing -= $n;
  303.     }
  304.     if (length($buf) > $len) {
  305.         $r->content(substr($buf,0,$len));
  306.         substr($buf, 0, $len) = '';
  307.     }
  308.     else {
  309.         $r->content($buf);
  310.         $buf='';
  311.     }
  312.     }
  313.     ${*$self}{'httpd_rbuf'} = $buf;
  314.  
  315.     $r;
  316. }
  317.  
  318.  
  319. sub _need_more
  320. {
  321.     my $self = shift;
  322.     #my($buf,$timeout,$fdset) = @_;
  323.     if ($_[1]) {
  324.     my($timeout, $fdset) = @_[1,2];
  325.     print STDERR "select(,,,$timeout)\n" if $DEBUG;
  326.     my $n = select($fdset,undef,undef,$timeout);
  327.     unless ($n) {
  328.         $self->reason(defined($n) ? "Timeout" : "select: $!");
  329.         return;
  330.     }
  331.     }
  332.     print STDERR "sysread()\n" if $DEBUG;
  333.     my $n = sysread($self, $_[0], 2048, length($_[0]));
  334.     $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n;
  335.     $n;
  336. }
  337.  
  338.  
  339. sub read_buffer
  340. {
  341.     my $self = shift;
  342.     my $old = ${*$self}{'httpd_rbuf'};
  343.     if (@_) {
  344.     ${*$self}{'httpd_rbuf'} = shift;
  345.     }
  346.     $old;
  347. }
  348.  
  349.  
  350. sub reason
  351. {
  352.     my $self = shift;
  353.     my $old = ${*$self}{'httpd_reason'};
  354.     if (@_) {
  355.         ${*$self}{'httpd_reason'} = shift;
  356.     }
  357.     $old;
  358. }
  359.  
  360.  
  361. sub proto_ge
  362. {
  363.     my $self = shift;
  364.     ${*$self}{'httpd_client_proto'} >= _http_version(shift);
  365. }
  366.  
  367.  
  368. sub _http_version
  369. {
  370.     local($_) = shift;
  371.     return 0 unless m,^(?:HTTP/)?(\d+)\.(\d+)$,i;
  372.     $1 * 1000 + $2;
  373. }
  374.  
  375.  
  376. sub antique_client
  377. {
  378.     my $self = shift;
  379.     ${*$self}{'httpd_client_proto'} < $HTTP_1_0;
  380. }
  381.  
  382.  
  383. sub force_last_request
  384. {
  385.     my $self = shift;
  386.     ${*$self}{'httpd_nomore'}++;
  387. }
  388.  
  389. sub head_request
  390. {
  391.     my $self = shift;
  392.     ${*$self}{'httpd_head'};
  393. }
  394.  
  395.  
  396. sub send_status_line
  397. {
  398.     my($self, $status, $message, $proto) = @_;
  399.     return if $self->antique_client;
  400.     $status  ||= RC_OK;
  401.     $message ||= status_message($status) || "";
  402.     $proto   ||= $HTTP::Daemon::PROTO || "HTTP/1.1";
  403.     print $self "$proto $status $message$CRLF";
  404. }
  405.  
  406.  
  407. sub send_crlf
  408. {
  409.     my $self = shift;
  410.     print $self $CRLF;
  411. }
  412.  
  413.  
  414. sub send_basic_header
  415. {
  416.     my $self = shift;
  417.     return if $self->antique_client;
  418.     $self->send_status_line(@_);
  419.     print $self "Date: ", time2str(time), $CRLF;
  420.     my $product = $self->daemon->product_tokens;
  421.     print $self "Server: $product$CRLF" if $product;
  422. }
  423.  
  424.  
  425. sub send_response
  426. {
  427.     my $self = shift;
  428.     my $res = shift;
  429.     if (!ref $res) {
  430.     $res ||= RC_OK;
  431.     $res = HTTP::Response->new($res, @_);
  432.     }
  433.     my $content = $res->content;
  434.     my $chunked;
  435.     unless ($self->antique_client) {
  436.     my $code = $res->code;
  437.     $self->send_basic_header($code, $res->message, $res->protocol);
  438.     if ($code =~ /^(1\d\d|[23]04)$/) {
  439.         # make sure content is empty
  440.         $res->remove_header("Content-Length");
  441.         $content = "";
  442.     }
  443.     elsif ($res->request && $res->request->method eq "HEAD") {
  444.         # probably OK
  445.     }
  446.     elsif (ref($content) eq "CODE") {
  447.         if ($self->proto_ge("HTTP/1.1")) {
  448.         $res->push_header("Transfer-Encoding" => "chunked");
  449.         $chunked++;
  450.         }
  451.         else {
  452.         $self->force_last_request;
  453.         }
  454.     }
  455.     elsif (length($content)) {
  456.         $res->header("Content-Length" => length($content));
  457.     }
  458.     else {
  459.         $self->force_last_request;
  460.             $res->header('connection','close'); 
  461.     }
  462.     print $self $res->headers_as_string($CRLF);
  463.     print $self $CRLF;  # separates headers and content
  464.     }
  465.     if ($self->head_request) {
  466.     # no content
  467.     }
  468.     elsif (ref($content) eq "CODE") {
  469.     while (1) {
  470.         my $chunk = &$content();
  471.         last unless defined($chunk) && length($chunk);
  472.         if ($chunked) {
  473.         printf $self "%x%s%s%s", length($chunk), $CRLF, $chunk, $CRLF;
  474.         }
  475.         else {
  476.         print $self $chunk;
  477.         }
  478.     }
  479.     print $self "0$CRLF$CRLF" if $chunked;  # no trailers either
  480.     }
  481.     elsif (length $content) {
  482.     print $self $content;
  483.     }
  484. }
  485.  
  486.  
  487. sub send_redirect
  488. {
  489.     my($self, $loc, $status, $content) = @_;
  490.     $status ||= RC_MOVED_PERMANENTLY;
  491.     Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
  492.     $self->send_basic_header($status);
  493.     my $base = $self->daemon->url;
  494.     $loc = $HTTP::URI_CLASS->new($loc, $base) unless ref($loc);
  495.     $loc = $loc->abs($base);
  496.     print $self "Location: $loc$CRLF";
  497.     if ($content) {
  498.     my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
  499.     print $self "Content-Type: $ct$CRLF";
  500.     }
  501.     print $self $CRLF;
  502.     print $self $content if $content && !$self->head_request;
  503.     $self->force_last_request;  # no use keeping the connection open
  504. }
  505.  
  506.  
  507. sub send_error
  508. {
  509.     my($self, $status, $error) = @_;
  510.     $status ||= RC_BAD_REQUEST;
  511.     Carp::croak("Status '$status' is not an error") unless is_error($status);
  512.     my $mess = status_message($status);
  513.     $error  ||= "";
  514.     $mess = <<EOT;
  515. <title>$status $mess</title>
  516. <h1>$status $mess</h1>
  517. $error
  518. EOT
  519.     unless ($self->antique_client) {
  520.         $self->send_basic_header($status);
  521.         print $self "Content-Type: text/html$CRLF";
  522.     print $self "Content-Length: " . length($mess) . $CRLF;
  523.         print $self $CRLF;
  524.     }
  525.     print $self $mess unless $self->head_request;
  526.     $status;
  527. }
  528.  
  529.  
  530. sub send_file_response
  531. {
  532.     my($self, $file) = @_;
  533.     if (-d $file) {
  534.     $self->send_dir($file);
  535.     }
  536.     elsif (-f _) {
  537.     # plain file
  538.     local(*F);
  539.     sysopen(F, $file, 0) or 
  540.       return $self->send_error(RC_FORBIDDEN);
  541.     binmode(F);
  542.     my($ct,$ce) = guess_media_type($file);
  543.     my($size,$mtime) = (stat _)[7,9];
  544.     unless ($self->antique_client) {
  545.         $self->send_basic_header;
  546.         print $self "Content-Type: $ct$CRLF";
  547.         print $self "Content-Encoding: $ce$CRLF" if $ce;
  548.         print $self "Content-Length: $size$CRLF" if $size;
  549.         print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime;
  550.         print $self $CRLF;
  551.     }
  552.     $self->send_file(\*F) unless $self->head_request;
  553.     return RC_OK;
  554.     }
  555.     else {
  556.     $self->send_error(RC_NOT_FOUND);
  557.     }
  558. }
  559.  
  560.  
  561. sub send_dir
  562. {
  563.     my($self, $dir) = @_;
  564.     $self->send_error(RC_NOT_FOUND) unless -d $dir;
  565.     $self->send_error(RC_NOT_IMPLEMENTED);
  566. }
  567.  
  568.  
  569. sub send_file
  570. {
  571.     my($self, $file) = @_;
  572.     my $opened = 0;
  573.     local(*FILE);
  574.     if (!ref($file)) {
  575.     open(FILE, $file) || return undef;
  576.     binmode(FILE);
  577.     $file = \*FILE;
  578.     $opened++;
  579.     }
  580.     my $cnt = 0;
  581.     my $buf = "";
  582.     my $n;
  583.     while ($n = sysread($file, $buf, 8*1024)) {
  584.     last if !$n;
  585.     $cnt += $n;
  586.     print $self $buf;
  587.     }
  588.     close($file) if $opened;
  589.     $cnt;
  590. }
  591.  
  592.  
  593. sub daemon
  594. {
  595.     my $self = shift;
  596.     ${*$self}{'httpd_daemon'};
  597. }
  598.  
  599.  
  600. 1;
  601.  
  602. __END__
  603.  
  604. =head1 NAME
  605.  
  606. HTTP::Daemon - a simple http server class
  607.  
  608. =head1 SYNOPSIS
  609.  
  610.   use HTTP::Daemon;
  611.   use HTTP::Status;
  612.  
  613.   my $d = HTTP::Daemon->new || die;
  614.   print "Please contact me at: <URL:", $d->url, ">\n";
  615.   while (my $c = $d->accept) {
  616.       while (my $r = $c->get_request) {
  617.       if ($r->method eq 'GET' and $r->url->path eq "/xyzzy") {
  618.               # remember, this is *not* recommended practice :-)
  619.           $c->send_file_response("/etc/passwd");
  620.       }
  621.       else {
  622.           $c->send_error(RC_FORBIDDEN)
  623.       }
  624.       }
  625.       $c->close;
  626.       undef($c);
  627.   }
  628.  
  629. =head1 DESCRIPTION
  630.  
  631. Instances of the C<HTTP::Daemon> class are HTTP/1.1 servers that
  632. listen on a socket for incoming requests. The C<HTTP::Daemon> is a
  633. subclass of C<IO::Socket::INET>, so you can perform socket operations
  634. directly on it too.
  635.  
  636. The accept() method will return when a connection from a client is
  637. available.  The returned value will be an C<HTTP::Daemon::ClientConn>
  638. object which is another C<IO::Socket::INET> subclass.  Calling the
  639. get_request() method on this object will read data from the client and
  640. return an C<HTTP::Request> object.  The ClientConn object also provide
  641. methods to send back various responses.
  642.  
  643. This HTTP daemon does not fork(2) for you.  Your application, i.e. the
  644. user of the C<HTTP::Daemon> is responsible for forking if that is
  645. desirable.  Also note that the user is responsible for generating
  646. responses that conform to the HTTP/1.1 protocol.
  647.  
  648. The following methods of C<HTTP::Daemon> are new (or enhanced) relative
  649. to the C<IO::Socket::INET> base class:
  650.  
  651. =over 4
  652.  
  653. =item $d = HTTP::Daemon->new
  654.  
  655. =item $d = HTTP::Daemon->new( %opts )
  656.  
  657. The constructor method takes the same arguments as the
  658. C<IO::Socket::INET> constructor, but unlike its base class it can also
  659. be called without any arguments.  The daemon will then set up a listen
  660. queue of 5 connections and allocate some random port number.
  661.  
  662. A server that wants to bind to some specific address on the standard
  663. HTTP port will be constructed like this:
  664.  
  665.   $d = HTTP::Daemon->new(
  666.            LocalAddr => 'www.thisplace.com',
  667.            LocalPort => 80,
  668.        );
  669.  
  670. See L<IO::Socket::INET> for a description of other arguments that can
  671. be used configure the daemon during construction.
  672.  
  673. =item $c = $d->accept
  674.  
  675. =item $c = $d->accept( $pkg )
  676.  
  677. =item ($c, $peer_addr) = $d->accept
  678.  
  679. This method works the same the one provided by the base class, but it
  680. returns an C<HTTP::Daemon::ClientConn> reference by default.  If a
  681. package name is provided as argument, then the returned object will be
  682. blessed into the given class.  It is probably a good idea to make that
  683. class a subclass of C<HTTP::Daemon::ClientConn>.
  684.  
  685. The accept method will return C<undef> if timeouts have been enabled
  686. and no connection is made within the given time.  The timeout() method
  687. is described in L<IO::Socket>.
  688.  
  689. In list context both the client object and the peer address will be
  690. returned; see the description of the accept method L<IO::Socket> for
  691. details.
  692.  
  693. =item $d->url
  694.  
  695. Returns a URL string that can be used to access the server root.
  696.  
  697. =item $d->product_tokens
  698.  
  699. Returns the name that this server will use to identify itself.  This
  700. is the string that is sent with the C<Server> response header.  The
  701. main reason to have this method is that subclasses can override it if
  702. they want to use another product name.
  703.  
  704. The default is the string "libwww-perl-daemon/#.##" where "#.##" is
  705. replaced with the version number of this module.
  706.  
  707. =back
  708.  
  709. The C<HTTP::Daemon::ClientConn> is a C<IO::Socket::INET>
  710. subclass. Instances of this class are returned by the accept() method
  711. of C<HTTP::Daemon>.  The following methods are provided:
  712.  
  713. =over 4
  714.  
  715. =item $c->get_request
  716.  
  717. =item $c->get_request( $headers_only )
  718.  
  719. This method read data from the client and turns it into an
  720. C<HTTP::Request> object which is returned.  It returns C<undef>
  721. if reading fails.  If it fails, then the C<HTTP::Daemon::ClientConn>
  722. object ($c) should be discarded, and you should not try call this
  723. method again on it.  The $c->reason method might give you some
  724. information about why $c->get_request failed.
  725.  
  726. The get_request() method will normally not return until the whole
  727. request has been received from the client.  This might not be what you
  728. want if the request is an upload of a large file (and with chunked
  729. transfer encoding HTTP can even support infinite request messages -
  730. uploading live audio for instance).  If you pass a TRUE value as the
  731. $headers_only argument, then get_request() will return immediately
  732. after parsing the request headers and you are responsible for reading
  733. the rest of the request content.  If you are going to call
  734. $c->get_request again on the same connection you better read the
  735. correct number of bytes.
  736.  
  737. =item $c->read_buffer
  738.  
  739. =item $c->read_buffer( $new_value )
  740.  
  741. Bytes read by $c->get_request, but not used are placed in the I<read
  742. buffer>.  The next time $c->get_request is called it will consume the
  743. bytes in this buffer before reading more data from the network
  744. connection itself.  The read buffer is invalid after $c->get_request
  745. has failed.
  746.  
  747. If you handle the reading of the request content yourself you need to
  748. empty this buffer before you read more and you need to place
  749. unconsumed bytes here.  You also need this buffer if you implement
  750. services like I<101 Switching Protocols>.
  751.  
  752. This method always return the old buffer content and can optionally
  753. replace the buffer content if you pass it an argument.
  754.  
  755. =item $c->reason
  756.  
  757. When $c->get_request returns C<undef> you can obtain a short string
  758. describing why it happened by calling $c->reason.
  759.  
  760. =item $c->proto_ge( $proto )
  761.  
  762. Return TRUE if the client announced a protocol with version number
  763. greater or equal to the given argument.  The $proto argument can be a
  764. string like "HTTP/1.1" or just "1.1".
  765.  
  766. =item $c->antique_client
  767.  
  768. Return TRUE if the client speaks the HTTP/0.9 protocol.  No status
  769. code and no headers should be returned to such a client.  This should
  770. be the same as !$c->proto_ge("HTTP/1.0").
  771.  
  772. =item $c->head_request
  773.  
  774. Return TRUE if the last request was a C<HEAD> request.  No content
  775. body must be generated for these requests.
  776.  
  777. =item $c->force_last_request
  778.  
  779. Make sure that $c->get_request will not try to read more requests off
  780. this connection.  If you generate a response that is not self
  781. delimiting, then you should signal this fact by calling this method.
  782.  
  783. This attribute is turned on automatically if the client announces
  784. protocol HTTP/1.0 or worse and does not include a "Connection:
  785. Keep-Alive" header.  It is also turned on automatically when HTTP/1.1
  786. or better clients send the "Connection: close" request header.
  787.  
  788. =item $c->send_status_line
  789.  
  790. =item $c->send_status_line( $code )
  791.  
  792. =item $c->send_status_line( $code, $mess )
  793.  
  794. =item $c->send_status_line( $code, $mess, $proto )
  795.  
  796. Send the status line back to the client.  If $code is omitted 200 is
  797. assumed.  If $mess is omitted, then a message corresponding to $code
  798. is inserted.  If $proto is missing the content of the
  799. $HTTP::Daemon::PROTO variable is used.
  800.  
  801. =item $c->send_crlf
  802.  
  803. Send the CRLF sequence to the client.
  804.  
  805. =item $c->send_basic_header
  806.  
  807. =item $c->send_basic_header( $code )
  808.  
  809. =item $c->send_basic_header( $code, $mess )
  810.  
  811. =item $c->send_basic_header( $code, $mess, $proto )
  812.  
  813. Send the status line and the "Date:" and "Server:" headers back to
  814. the client.  This header is assumed to be continued and does not end
  815. with an empty CRLF line.
  816.  
  817. See the description of send_status_line() for the description of the
  818. accepted arguments.
  819.  
  820. =item $c->send_response( $res )
  821.  
  822. Write a C<HTTP::Response> object to the
  823. client as a response.  We try hard to make sure that the response is
  824. self delimiting so that the connection can stay persistent for further
  825. request/response exchanges.
  826.  
  827. The content attribute of the C<HTTP::Response> object can be a normal
  828. string or a subroutine reference.  If it is a subroutine, then
  829. whatever this callback routine returns is written back to the
  830. client as the response content.  The routine will be called until it
  831. return an undefined or empty value.  If the client is HTTP/1.1 aware
  832. then we will use chunked transfer encoding for the response.
  833.  
  834. =item $c->send_redirect( $loc )
  835.  
  836. =item $c->send_redirect( $loc, $code )
  837.  
  838. =item $c->send_redirect( $loc, $code, $entity_body )
  839.  
  840. Send a redirect response back to the client.  The location ($loc) can
  841. be an absolute or relative URL. The $code must be one the redirect
  842. status codes, and defaults to "301 Moved Permanently"
  843.  
  844. =item $c->send_error
  845.  
  846. =item $c->send_error( $code )
  847.  
  848. =item $c->send_error( $code, $error_message )
  849.  
  850. Send an error response back to the client.  If the $code is missing a
  851. "Bad Request" error is reported.  The $error_message is a string that
  852. is incorporated in the body of the HTML entity body.
  853.  
  854. =item $c->send_file_response( $filename )
  855.  
  856. Send back a response with the specified $filename as content.  If the
  857. file is a directory we try to generate an HTML index of it.
  858.  
  859. =item $c->send_file( $filename )
  860.  
  861. =item $c->send_file( $fd )
  862.  
  863. Copy the file to the client.  The file can be a string (which
  864. will be interpreted as a filename) or a reference to an C<IO::Handle>
  865. or glob.
  866.  
  867. =item $c->daemon
  868.  
  869. Return a reference to the corresponding C<HTTP::Daemon> object.
  870.  
  871. =back
  872.  
  873. =head1 SEE ALSO
  874.  
  875. RFC 2616
  876.  
  877. L<IO::Socket::INET>, L<IO::Socket>
  878.  
  879. =head1 COPYRIGHT
  880.  
  881. Copyright 1996-2003, Gisle Aas
  882.  
  883. This library is free software; you can redistribute it and/or
  884. modify it under the same terms as Perl itself.
  885.  
  886.